home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / matt's utils 8sept / progress-indication.lisp < prev    next >
Encoding:
Text File  |  1992-08-23  |  10.4 KB  |  317 lines  |  [TEXT/CCL2]

  1. ;;;
  2. ;;; progress-indication.Lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines with-progress-indication and progress-step which provide a
  10. uniform way to note incremental progress during long operations. Fondly
  11. inspired by Symbolics' noting-progress mechanism.
  12.  
  13. Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
  14. bugs, comments, questions, and fixes to cornell@cs.umass.edu.
  15.  
  16.  
  17. ================================================================
  18. Status =========================================================
  19. ================================================================
  20. Implemented but the progress dialog can be deselected, which needs to be
  21. fixed.
  22.  
  23. Bug: Errors encountered during dolist-noting-progress cause a throw out of
  24. the loop WITH NO INDICATIONS that something went wrong!
  25.  
  26.  
  27. ================================================================
  28. Change history =================================================
  29. ================================================================
  30.  8-Jun-91 mc    Created.
  31. 25-Jul-91 mc    Added copyright and released.
  32. 18-Sep-91 mc    Fixed view-draw-contents box-dialog-item to draw outline in
  33.          container, not in the item itself.
  34. 14-Mar-92 mc    Added (require "QUICKDRAW").
  35. 21-Mar-92 mc    Changed view-draw-contents (box-dialog-item) to call
  36.          #_FrameRect so that QUICKDRAW isn't required.
  37.         Removed (require "QUICKDRAW").
  38. 22-Mar-92 mc    Fixed view-draw-contents :after (progress-dialog-item) to call
  39.          #_FillRect .
  40.         Fixed view-draw-contents :after (progress-dialog-item) to not
  41.          error when there are zero steps.
  42. 22-Apr-92 mc    Added fixes by markt@dgp.toronto.EDU (marked by mt) . Thank you!
  43. 19-Jul-92 mc    Bug: Calling progress-step with a numeric first arg and a null
  44.          second arg does not update the gray status bar.
  45.           mc    Fixed above bug.
  46. 23-Jul-92 mc    Changed box-dialog-item to progress-box-dialog-item to avoid
  47.          name conflict with Apple's box-dialog-item defined in
  48.          "scrollers.lisp"
  49. 23-Aug-92 mc    Defined dolist-noting-progress macro.
  50.         Added provide.
  51.         Fixed with-progress-indication (wasn't returning values
  52.          correctly).
  53.  
  54. |#
  55.  
  56.  
  57. (in-package "CCL")
  58.  
  59. (export '(WITH-PROGRESS-INDICATION
  60.            PROGRESS-STEP
  61.            DOLIST-NOTING-PROGRESS))
  62.  
  63.  
  64. #|
  65. (defun progress-step (step-num &optional step-text)
  66.   "progress-step
  67.      step-num &optional step-text
  68.  
  69. Visually indicates step number STEP-NUM has taken place. STEP-TEXT, if
  70. passed, is drawn too. Use nil for STEP-NUM to update just STEP-TEXT and not
  71. the visual indicator."
  72.   ;;
  73.   )
  74. |#
  75.  
  76.  
  77. (defmacro with-progress-indication ((num-steps title) form)
  78.   "with-progress-indication
  79.      ((num-steps title) form)
  80.  
  81. Executes FORM with a visual indication of percent done. NUM-STEPS is the
  82. total number of steps the task will take and is an integer. TITLE is a
  83. string used to label the entire task. During FORM's execution calls to
  84. progress-step can be made."
  85.   ;;
  86.   ;; Eval-time expansion.
  87.   ;;
  88.   (let ((dialog-var (gensym "dialog-"))
  89.         (results-var (gensym "result-")))
  90.     ;;
  91.     ;; Run-time expansion.
  92.     ;;
  93.     `(let* ((,dialog-var (make-instance 'progress-dialog
  94.                                         :num-steps ,num-steps :title ,title))
  95.             ,results-var)
  96.        (labels ((progress-step (step-num &optional step-text)
  97.                  (set-step ,dialog-var step-num step-text)))
  98.          ;;
  99.          (unwind-protect
  100.            (progn (setf ,results-var (multiple-value-list ,form))
  101.                   (values-list ,results-var))
  102.            (progn (window-close ,dialog-var)))))))
  103.  
  104.  
  105. ;;;
  106. ;;; The progress-box-dialog-item class.
  107. ;;;
  108.  
  109. (defclass progress-box-dialog-item (dialog-item)
  110.   ())
  111.  
  112. (defmethod view-contains-point-p  ((item progress-box-dialog-item)
  113.                                    point)
  114.   (declare (ignore point))
  115.   ;;
  116.   nil)
  117.  
  118. (defmethod view-draw-contents ((item progress-box-dialog-item))
  119.   "Draws a box around ITEM."
  120.   ;;
  121.   (let* ((topleft (view-position item))
  122.          (bottomright (add-points topleft (view-size item)))
  123.          (container (view-container item)))
  124.     ;Following was (frame-rect container topleft bottomright) :
  125.     (rlet ((p-rect :rect :topLeft topleft :bottomRight bottomright))
  126.       (with-focused-view container 
  127.         (#_FrameRect p-rect)))))
  128.  
  129.  
  130. ;;;
  131. ;;; The progress-dialog-item class.
  132. ;;;
  133.  
  134. (defclass progress-dialog-item (progress-box-dialog-item)
  135.   ((num-steps
  136.     :accessor progress-num-steps
  137.     :initarg :progress-num-steps)
  138.    (current-step
  139.     :accessor progress-current-step
  140.     :initform -1)
  141.    )
  142.   )
  143.  
  144.  
  145. (defmethod initialize-instance :after ((item progress-dialog-item)
  146.                                      &key progress-num-steps)
  147.   (unless progress-num-steps
  148.     (error ":progress-num-steps initarg required.")))
  149.  
  150.  
  151. (defmethod view-draw-contents :after ((item progress-dialog-item))
  152.   "Draws the percentage indicator based on progress-num-steps and
  153. progress-current-step."
  154.   ;;
  155.   ;; Draw only if progress-num-steps is non-zero (causes an error if
  156.   ;;  otherwise).
  157.   ;;
  158.   (when (and (numberp (progress-num-steps item))
  159.              (plusp (progress-num-steps item)))
  160.     (let* ((width (point-h (view-size item)))
  161.            (height (point-v (view-size item)))
  162.            (step-width (/ width (progress-num-steps item)))
  163.            (right (round (* (1+ (progress-current-step item)) step-width))))
  164.       ;Following was (fill-rect item *gray-pattern* 1 1 (1- right) (1- height)) :
  165.       (rlet ((p-rect :rect :topLeft #@(1 1)
  166.                      :bottomRight (make-point (1- right) (1- height))))
  167.         (with-focused-view item
  168.           (#_FillRect p-rect *gray-pattern*))))))
  169.  
  170.  
  171. (defmethod set-step ((item progress-dialog-item)
  172.                      (step-num integer)
  173.                      &optional step-text)
  174.   (declare (ignore step-text))
  175.   ;;
  176.   (when (>= step-num (progress-num-steps item))
  177.     (error "step-num (~S) >= declared number of steps (~S)."
  178.            step-num (progress-num-steps item)))
  179.   ;;
  180.   (setf (progress-current-step item) step-num)
  181.   (with-focused-view item               ; mt
  182.     (view-draw-contents item)           ; mt
  183.     ))
  184.  
  185.  
  186. ;;;
  187. ;;; The progress-dialog class.
  188. ;;;
  189.  
  190. (defclass progress-dialog (dialog)
  191.   ()
  192.   (:default-initargs
  193.     :WINDOW-TYPE :DOUBLE-EDGE-BOX :VIEW-POSITION '(:TOP 60)
  194.     :VIEW-SIZE #@(302 64) :CLOSE-BOX-P NIL
  195.     :VIEW-FONT '("Chicago" 12 :SRCOR :PLAIN)))
  196.  
  197.  
  198. (defmethod initialize-instance :after ((dialog progress-dialog)
  199.                                      &key num-steps title)
  200.   (unless num-steps
  201.     (error ":num-steps initarg required."))
  202.   (unless title
  203.     (error ":title initarg required."))
  204.   ;;
  205.   ;; Add the items, initialize 'title-text-item and 'progress-item.
  206.   ;;
  207.   (add-subviews dialog
  208.                 (MAKE-DIALOG-ITEM
  209.                  'STATIC-TEXT-DIALOG-ITEM #@(3 1) #@(293 16)
  210.                  title NIL :VIEW-NICK-NAME 'title-text-item)
  211.                 (MAKE-DIALOG-ITEM
  212.                  'STATIC-TEXT-DIALOG-ITEM #@(3 20) #@(293 22)
  213.                  "" NIL :VIEW-NICK-NAME 'step-text-item
  214.                  :view-font '("Helvetica" 9 :plain))
  215.                 (MAKE-DIALOG-ITEM
  216.                  'progress-dialog-item #@(3 48) #@(296 12)
  217.                  "" NIL :VIEW-NICK-NAME 'progress-item
  218.                  :progress-num-steps num-steps))
  219.   (view-draw-contents (view-named 'title-text-item dialog)))
  220.  
  221.  
  222. (defmethod set-step ((dialog progress-dialog) step-num &optional step-text)
  223.   ;;
  224.   (when step-text
  225.     (with-focused-view dialog           ; mt
  226.       (when step-text
  227.         (set-dialog-item-text (view-named 'step-text-item dialog) step-text))
  228.       ;; Following was (view-draw-contents (view-named 'step-text-item dialog))
  229.       (view-draw-contents dialog)       ; mt
  230.       ))
  231.   (when step-num
  232.     (set-step (view-named 'progress-item dialog) step-num)))
  233.  
  234.  
  235. ;;;================================================================
  236. ;;; Define the dolist-noting-progress macro
  237. ;;;================================================================
  238.  
  239. (defmacro dolist-noting-progress ((var listform &optional resultform str-message)
  240.                                  &body body)
  241.   "Evaluates listform, which produces a list, and executes the body once
  242. for every element in the list. On each iteration, var is bound to
  243. successive elements of the list. Upon completion, resultform is
  244. evaluated, and the value is returned. If resultform is omitted, the
  245. result is nil. Str-message is a string that serves as the progress
  246. indication dialog's title. It defaults to 'Doing <listform result>…',
  247. where <listform result> is the result of evaluating listform, which is
  248. evaluated only once."
  249.   ;;
  250.   ;; Do eval-time bindings.
  251.   ;;
  252.   (let ((sym-list-var (gensym)))
  253.     ;;
  254.     ;; Return the run-time expansion.
  255.     ;;
  256.     `(let* ((,sym-list-var ,listform)   ;stops multiple evaluations
  257.             (int-length (length ,sym-list-var))
  258.             (str-message (if (stringp ,str-message)
  259.                            ,str-message
  260.                            (format nil "Doing ~A…" ,sym-list-var)))
  261.             ,var)
  262.        (with-progress-indication (int-length str-message)
  263.          (dotimes (int-index int-length ,resultform)
  264.            (setf ,var (elt ,sym-list-var int-index))
  265.            (progress-step int-index (format nil "~A" ,var))
  266.            ,@body)))))
  267.  
  268.  
  269. ;;; Done.
  270.  
  271. (provide "PROGRESS-INDICATION")
  272.  
  273.  
  274.  
  275. #|
  276. ;;; Define some examples.
  277.  
  278. (dolist-noting-progress (win (windows) (values-list '(1 2 3)) "Doing Windows…")
  279.   (format t "~&Doing ~S now." win)
  280.   (sleep 0.7))
  281.  
  282.  
  283. (defun run-demo ()
  284.   ""
  285.   ;;
  286.   (let* ((windows (windows))
  287.          (len (length windows)))
  288.     (with-progress-indication (len "Windows Demo")
  289.       (progn
  290.         (progress-step nil "Setting up")
  291.         (sleep .5)
  292.         (dotimes (count len)
  293.           (progress-step count (format nil "~A" (elt windows count)))
  294.           (sleep 1))
  295.         (progress-step nil "Cleaning up")
  296.         (sleep .5)))))
  297.  
  298.  
  299. ;;; Note: when a GC occured during the show-bug button's action the
  300. ;;;  progress window was grayed-out then the progress continued **but
  301. ;;;  without an updated title**!
  302.  
  303. (defun show-bug ()
  304.   (MAKE-INSTANCE
  305.    'window
  306.    :WINDOW-TYPE :DOCUMENT
  307.    :VIEW-SIZE #@(129 97)
  308.    :VIEW-SUBVIEWS (LIST
  309.                    (MAKE-DIALOG-ITEM 'BUTTON-DIALOG-ITEM
  310.                                      #@(13 16)
  311.                                      #@(88 18)
  312.                                      "Show it"
  313.                                      #'(lambda (item)
  314.                                          (declare (ignore item))
  315.                                          (run-demo))))))
  316.  
  317. |#